unit GeneratorU;

interface

uses
  System.Classes, Data.DB, Generics.Collections, SysUtils, ioutils;

type
  TGenerator = class
  private
    FOutput: TStringStream;
    FTables: TStrings;
    FDSCallback: TFunc<String, TDataSet>;
    FCurrentDS: TDataSet;
    procedure EmitGettersSetters;
    function GetFieldName(AFieldName: String): String;
    function IsReferenceType(const ATypeName: String): Boolean;
  protected
    procedure EmitInterfaceUses;
    procedure EmitProperty(F: TField);
    procedure EmitSetter(F: TField);
    procedure EmitField(F: TField);
    procedure EmitFields;
    procedure EmitProperties(TableName: String);
    procedure EmitClass(TableName: String);
    procedure EmitClassEnd;
    procedure EmitUtils;
    procedure EmitSettersBody(const AClassName, ATableName: String);
    procedure EmitSetterBody(const AClassName: String; F: TField;
      ATableName: String);
    procedure EmitHelpComments;
    procedure EmitComment(const Value: String);
    function GetDelphiType(FT: TFieldType): String;
    function GetProperCase(const Value: String): String;
  public
    constructor Create(ATables: TStrings;
      GetFieldsCallback: TFunc<String, TDataSet>); virtual;
    destructor Destroy; override;
    procedure Execute;
    property Output: TStringStream read FOutput;
  end;

implementation

{ TGenerator }

uses CommonsU, System.StrUtils;

constructor TGenerator.Create(ATables: TStrings;
  GetFieldsCallback: TFunc<String, TDataSet>);
begin
  inherited Create;
  FTables := ATables;
  FOutput := TStringStream.Create;
  FDSCallback := GetFieldsCallback;
end;

destructor TGenerator.Destroy;
begin
  FOutput.Free;
  inherited;
end;

procedure TGenerator.Execute;
var
  LTable: String;
  LClassName: String;
begin
  FOutput.WriteString('{ ================================================ }' + sLineBreak);
  FOutput.WriteString('{ Proudly generated by the DORM entities generator }' + sLineBreak);
  FOutput.WriteString('{ generated on ' + DateTimeToStr(now) + '                 }' + sLineBreak);
  FOutput.WriteString('{ DO NOT CHANGE THIS FILE!!!                       }' + sLineBreak);
  FOutput.WriteString('{ ================================================ }' + sLineBreak);
  FOutput.WriteString('unit ' + tpath.GetFileNameWithoutExtension
    (TConfig.OUTPUTFILENAME) + ';' + sLineBreak + sLineBreak);
  FOutput.WriteString('interface' + sLineBreak + sLineBreak);
  EmitInterfaceUses;
  FOutput.WriteString('type' + sLineBreak);
  for LTable in FTables do
  begin
    FCurrentDS := FDSCallback(LTable);
    EmitClass(LTable);
    FOutput.WriteString('  strict private' + sLineBreak);
    EmitFields;
    FOutput.WriteString('  strict protected' + sLineBreak);
    EmitGettersSetters;
    FOutput.WriteString('  public' + sLineBreak);
    FOutput.WriteString('    constructor Create; virtual;' + sLineBreak);
    FOutput.WriteString('    destructor Destroy; override;' + sLineBreak);
    EmitProperties(LTable);
    EmitClassEnd;
  end;

  EmitHelpComments;

  FOutput.WriteString('  procedure __WriteToStream(AStream: TStream; const Value: String);' + sLineBreak);
  FOutput.WriteString('  function __ReadFromStream(AStream: TStream): String;' + sLineBreak);

  FOutput.WriteString('implementation' + sLineBreak + sLineBreak);
  for LTable in FTables do
  begin
    FCurrentDS := FDSCallback(LTable);
    LClassName := LTable;
    LClassName := 'T' + TConfig.CLASSSUFFIX + GetProperCase(LClassName);
    EmitSettersBody(LClassName, LTable);
  end;
  EmitUtils;
  FOutput.WriteString('end.');
end;

function TGenerator.GetDelphiType(FT: TFieldType): String;
begin
  case FT of
    ftString:
      Result := 'String';
    ftSmallint, ftInteger, ftWord, ftLongWord, ftShortint:
      Result := 'Integer';
    ftByte:
      Result := 'Byte';
    ftLargeint:
      Result := 'Int64';
    ftBoolean:
      Result := 'Boolean';
    ftFloat, ftSingle, ftExtended:
      Result := 'Double';
    ftCurrency, ftBCD:
      Result := 'Currency';
    ftDate:
      Result := 'TDate';
    ftTime:
      Result := 'TTime';
    ftDateTime:
      Result := 'TDateTime';
    ftTimeStamp:
      Result := 'TDateTime {timestamp}';
    ftAutoInc:
      Result := 'Integer {autoincrement}';
    ftBlob, ftMemo, ftGraphic, ftFmtMemo, ftWideMemo, ftStream:
      Result := 'TStream';
    ftFixedChar:
      Result := 'String {fixedchar}';
    ftWideString:
      Result := 'String';
  else
    Result := '<UNSUPPORTED TYPE>';
    // + TEnum.GetName<TFieldType>(FT) + '>';
  end;
end;

function TGenerator.GetFieldName(AFieldName: String): String;
begin
  Result := 'F' + GetProperCase(AFieldName);
end;

function TGenerator.GetProperCase(const Value: String): String;
var
  Pieces: TArray<String>;
  s: String;
begin
  if not TConfig.CAPITALIZE then
    Exit(Value);

  Result := '';
  if Value.Length <= 2 then
    Exit(Value.ToUpper);

  Pieces := Value.ToLower.Split(['_']);
  for s in Pieces do
  begin
    if s = 'id' then
      Result := Result + 'ID'
    else
      Result := Result + uppercase(s.Chars[0]) + s.Substring(1);
  end;
end;

function TGenerator.IsReferenceType(const ATypeName: String): Boolean;
begin
  Result := ATypeName.Equals('TStream');
end;

procedure TGenerator.EmitClass(TableName: String);
begin
  FOutput.WriteString('  [Entity(''' + TableName + ''')]' + sLineBreak);
  FOutput.WriteString('  T' + TConfig.CLASSSUFFIX + GetProperCase(TableName) +
    ' = class(' + TConfig.PARENTCLASS + ')' + sLineBreak);
end;

procedure TGenerator.EmitClassEnd;
begin
  FOutput.WriteString('  end;' + sLineBreak + sLineBreak);
end;

procedure TGenerator.EmitComment(const Value: String);
begin
  FOutput.WriteString('{ ' + Value.PadRight(120, ' ') + ' }' + sLineBreak);
end;

procedure TGenerator.EmitField(F: TField);
var
  PropName: string;
  LFieldName: string;
begin
  if (not TConfig.PROPERTYID) and (LowerCase(F.FieldName) = 'id') then
    Exit;
  if (not TConfig.PROPERTYOBJVERSION) and (LowerCase(F.FieldName) = 'objversion')
  then
    Exit;

  LFieldName := GetFieldName(F.FieldName);
  FOutput.WriteString('    ' + LFieldName + ': ' + GetDelphiType(F.DataType) +
    ';' + sLineBreak);
end;

procedure TGenerator.EmitFields;
var
  i: Integer;
  ExcludedFields: TArray<string>;
begin
  ExcludedFields := TConfig.EXCLUDEDCOLUMNS.Split([',']);
  for i := 0 to FCurrentDS.Fields.Count - 1 do
  begin
    if not MatchText(FCurrentDS.Fields[i].FieldName, ExcludedFields) then
      EmitField(FCurrentDS.Fields[i]);
  end;
end;

procedure TGenerator.EmitProperty(F: TField);
var
  PropName: string;
begin
  // if NoPropertyCase.Checked then
  // FOutput.WriteString(Format('  [Column(''%s'')]', [F.FieldName]) + sLineBreak
  // + '  property ' + F.FieldName + ': ' + GetDelphiType(F.DataType) + ';' +
  // sLineBreak)
  // else
  if (not TConfig.PROPERTYID) and (LowerCase(F.FieldName) = 'id') then
    Exit;
  if (not TConfig.PROPERTYOBJVERSION) and (LowerCase(F.FieldName) = 'objversion')
  then
    Exit;

  PropName := GetProperCase(F.FieldName);

  if TConfig.COLUMNATTRIBUTE then
    FOutput.WriteString(Format('    [Column(''%s'')]' + sLineBreak,
      [F.FieldName]));

  FOutput.WriteString('    property ' + PropName + ': ' +
    GetDelphiType(F.DataType) + ' read F' + PropName + ' write Set' + PropName +
    ';' + sLineBreak);
end;

procedure TGenerator.EmitSetter(F: TField);
var
  PropName: string;
begin
  if (not TConfig.PROPERTYID) and (LowerCase(F.FieldName) = 'id') then
    Exit;

  if (not TConfig.PROPERTYOBJVERSION) and (LowerCase(F.FieldName) = 'objversion')
  then
    Exit;

  PropName := GetProperCase(F.FieldName);
  FOutput.WriteString('    procedure Set' + PropName + '(const Value: ' +
    GetDelphiType(F.DataType) + '); virtual;' + sLineBreak);
end;

procedure TGenerator.EmitSetterBody(const AClassName: String; F: TField;
  ATableName: String);
var
  PropName: string;
  ExcludedFields, FieldsSerializeAsString: TArray<string>;
  FieldName: string;
begin
  if (not TConfig.PROPERTYID) and (LowerCase(F.FieldName) = 'id') then
    Exit;
  if (not TConfig.PROPERTYOBJVERSION) and (LowerCase(F.FieldName) = 'objversion')
  then
    Exit;

  FieldsSerializeAsString := TConfig.FieldsSerializeAsString.Split([',']);
  ExcludedFields := TConfig.EXCLUDEDCOLUMNS.Split([',']);
  if not MatchText(F.FieldName, ExcludedFields) then
  begin
    PropName := GetProperCase(F.FieldName);
    FOutput.WriteString('procedure ' + AClassName + '.Set' + PropName +
      '(const Value: ' + GetDelphiType(F.DataType) + ');' + sLineBreak);
    FieldName := ATableName + '.' + F.FieldName;
    if MatchText(FieldName, FieldsSerializeAsString) then
      FOutput.WriteString('begin' + sLineBreak + '  if Assigned(F' + PropName +
        ') then' + sLineBreak + '    F' + PropName + '.Free;' + sLineBreak +
        '  F' + PropName + ' := Value;' + sLineBreak + 'end;' + sLineBreak +
        sLineBreak)
    else
      FOutput.WriteString('begin' + sLineBreak + '  F' + PropName + ' := Value;'
        + sLineBreak + 'end;' + sLineBreak + sLineBreak);
  end;
end;

procedure TGenerator.EmitProperties(TableName: String);
var
  i: Integer;
  ExcludedFields, TablesColumnsNullable, FieldsSerializeAsString
    : TArray<string>;
  FieldName: string;
begin
  ExcludedFields := TConfig.EXCLUDEDCOLUMNS.Split([',']);
  TablesColumnsNullable := TConfig.TablesColumnsNullable.Split([',']);
  FieldsSerializeAsString := TConfig.FieldsSerializeAsString.Split([',']);
  for i := 0 to FCurrentDS.Fields.Count - 1 do
  begin
    if not MatchText(FCurrentDS.Fields[i].FieldName, ExcludedFields) then
    begin
      FieldName := TableName + '.' + FCurrentDS.Fields[i].FieldName;
      if MatchText(FieldName, TablesColumnsNullable) then
        FOutput.WriteString('    [Nullable]' + sLineBreak);
      if MatchText(FieldName, FieldsSerializeAsString) then
        FOutput.WriteString('    [MapperSerializeAsString(''utf-16'')]' +
          sLineBreak);
      EmitProperty((FCurrentDS.Fields[i]));
    end;
  end;
end;

procedure TGenerator.EmitGettersSetters;
var
  i: Integer;
  ExcludedFields: TArray<string>;
begin
  ExcludedFields := TConfig.EXCLUDEDCOLUMNS.Split([',']);
  for i := 0 to FCurrentDS.Fields.Count - 1 do
  begin
    if not MatchText(FCurrentDS.Fields[i].FieldName, ExcludedFields) then
      EmitSetter((FCurrentDS.Fields[i]))
  end;
end;

procedure TGenerator.EmitHelpComments;
begin
  EmitComment(StringOfChar('*', 120));
  EmitComment
    ('Classes generated with the generators must not be changed by hand.');
  EmitComment('When you add a new table or add/delete/change a table field, ');
  EmitComment
    ('the generator must regenerate the classes, so you loose all your changes.');
  EmitComment
    ('If you need logic, events or other cool stuf that DORM provides, you');
  EmitComment
    ('have to inherit from the classes and add al the stuff you need in THAT class.');
  EmitComment
    ('It is a good habit starting to use derived classes as soon as you need,');
  EmitComment
    ('that entity so that you dont have to hange your code when, after some time,');
  EmitComment('some logic need to be added to the entity.');
  EmitComment
    ('Also, all the relations between the entities must be implemented ni the derived classes.');
  EmitComment(StringOfChar('-', 120));
  EmitComment
    ('Just as *reminder*, here''s all the methods that you can implement in the inherited classes.');
  EmitComment
    ('Remember, you dont have to override these methods, only (public or protected, it depends');
  EmitComment('from the available RTTI) implementation is needed. ');
  EmitComment('DORM will call them for you! Yes, what a great ORM!!');
  EmitComment('');
  EmitComment
    ('  // Called at every validations. Validations happends at every CRUD related calls.');
  EmitComment('  procedure Validate;');
  EmitComment('  // Called after "Validate" only while inserting');
  EmitComment('  procedure InsertValidate;');
  EmitComment('  // Called after "Validate" only while Updating');
  EmitComment('  procedure UpdateValidate;');
  EmitComment('  // Called after "Validate" only while Deleting');
  EmitComment('  procedure DeleteValidate;');
  EmitComment('  // Events related methods');
  EmitComment('  procedure OnBeforeLoad;');
  EmitComment('  procedure OnAfterLoad;');
  EmitComment('  procedure OnBeforePersist;');
  EmitComment('  procedure OnAfterPersist;');
  EmitComment('  procedure OnBeforeInsert;');
  EmitComment('  procedure OnAfterInsert;');
  EmitComment('  procedure OnBeforeUpdate;');
  EmitComment('  procedure OnAfterUpdate;');
  EmitComment('  procedure OnBeforeDelete;');
  EmitComment('  procedure OnAfterDelete;');
  EmitComment(StringOfChar('*', 120));
end;

procedure TGenerator.EmitInterfaceUses;
begin
  if TConfig.INTERFACEUSES <> '' then
    FOutput.WriteString('uses ' + sLineBreak + '  ' + TConfig.INTERFACEUSES +
      ';' + sLineBreak + sLineBreak);
end;

procedure TGenerator.EmitSettersBody(const AClassName, ATableName: String);
var
  i: Integer;
  LConstructorBody: TList<String>;
  LDelphiType: string;
  row: String;
begin
  LConstructorBody := TList<String>.Create;
  try
    for i := 0 to FCurrentDS.Fields.Count - 1 do
    begin
      EmitSetterBody(AClassName, FCurrentDS.Fields[i], ATableName);
      LDelphiType := GetDelphiType(FCurrentDS.Fields[i].DataType);
      if IsReferenceType(LDelphiType) then
      begin
        LConstructorBody.Add(GetFieldName(FCurrentDS.Fields[i].FieldName) +
          ' := TMemoryStream.Create;');
      end;
    end;

    // constructor
    FOutput.WriteString('constructor ' + AClassName + '.Create;' + sLineBreak);
    FOutput.WriteString('begin' + sLineBreak);
    FOutput.WriteString('  inherited;' + sLineBreak);
    for row in LConstructorBody do
    begin
      FOutput.WriteString('  ' + row + sLineBreak);
    end;
    FOutput.WriteString('end;' + sLineBreak + sLineBreak);

    // destructor
    FOutput.WriteString('destructor ' + AClassName + '.Destroy;' + sLineBreak);
    FOutput.WriteString('begin' + sLineBreak);
    for row in LConstructorBody do
    begin
      FOutput.WriteString('  if Assigned(' + row.Split([':'])[0].Trim + ') then'
        + sLineBreak + '    ' + row.Split([':'])[0].Trim + '.Free;' +
        sLineBreak);
    end;
    FOutput.WriteString('  inherited;' + sLineBreak);
    FOutput.WriteString('end;' + sLineBreak + sLineBreak);

  finally
    LConstructorBody.Free;
  end;
end;

procedure TGenerator.EmitUtils;
begin
  // writetostream
  FOutput.WriteString
    ('procedure __WriteToStream(AStream: TStream; const Value: String);' +
    sLineBreak);
  FOutput.WriteString('var' + sLineBreak);
  FOutput.WriteString('  LStreamWriter: TStreamWriter;' + sLineBreak);
  FOutput.WriteString('begin' + sLineBreak);
  FOutput.WriteString('  LStreamWriter := TStreamWriter.Create(AStream);' +
    sLineBreak);
  FOutput.WriteString('  try' + sLineBreak);
  FOutput.WriteString('    LStreamWriter.Write(Value);' + sLineBreak);
  FOutput.WriteString('  finally' + sLineBreak);
  FOutput.WriteString('    LStreamWriter.Free;' + sLineBreak);
  FOutput.WriteString('  end;' + sLineBreak);
  FOutput.WriteString('end;' + sLineBreak);

  // readfromstream
  FOutput.WriteString(sLineBreak);
  FOutput.WriteString('function __ReadFromStream(AStream: TStream): String;');
  FOutput.WriteString('var' + sLineBreak);
  FOutput.WriteString('  LStreamReader: TStreamReader;' + sLineBreak);
  FOutput.WriteString('begin' + sLineBreak);
  FOutput.WriteString('  LStreamReader := TStreamReader.Create(AStream);' +
    sLineBreak);
  FOutput.WriteString('  try' + sLineBreak);
  FOutput.WriteString('    Result := LStreamReader.ReadToEnd;' + sLineBreak);
  FOutput.WriteString('  finally' + sLineBreak);
  FOutput.WriteString('    LStreamReader.Free;' + sLineBreak);
  FOutput.WriteString('  end;' + sLineBreak);
  FOutput.WriteString('end;' + sLineBreak);
  FOutput.WriteString(sLineBreak);
end;

end.
